MacHack 1998/MacHack 1998.toast/The Hacks!/PCA Icon Arranger ƒ/MacInit.p

Text File | 1998-06-20 | 53.2 KB | 2,457 lines | [TEXT/PJMM]

unit MacInit;

{ Modification History }
{ 06/03/1998 PhC }
{ • Correction d'un bug dans l'affichage des valeurs propres }
{ • Correction d'un bug dans Dispose (err. -113) }
{ 05/25/1998 PhC }
{ • Modification pour CodeWarrior }
{   uses StandardFile, etc... }
{   MaxReel et MinReel 10E320->10E300 }
{        Modification TrouveVolume }
{        InitGraf et autres qd }
{   StringToReel etc... ne pas utiliser! }
{        Divers appels -> Universal Interfaces (i.e. GetDItem -> GetDialogItemText }
{            (utilisation de InterfacesUI }
{            TpprPort- > TpprPortRef }
{        round -> system.round }

interface

    uses
{$ifc undefined THINK_PASCAL}
        StandardFile, TextUtils, fp, Devices, Fonts, Sound, ToolUtils,
{$elsec}
        InterfacesUI,
{$endc}
        SANE, Printing;


{ Declarations to make the CW compiler happy. }
{ Do not use any of these calls in actual code! }
{$ifc undefined THINK_PASCAL}
    type
        DecStr = Str255;

    procedure Num2Str (f: decform;
                                    x: Extended;
                                    var s: DecStr);

    function Str2Num (s: DecStr): Extended;

{$endc}

    const
        MaxReel = 10E300;
        MinReel = -10E300;
        Epsilon = 10E-7;
        MenuHeight = 20;
        FileMenuID = 299;
        AppleID = 300;
        EditID = 301;
        TitreID = 400;
        FichID = 1000;
        ReelID = 2000;
        IntID = 2001;
        CardID = 5000;
        RefID = 5100;
        FabricID = 5200;
        NellyID = 5300;
        ShowfID = 5400;
        MenuID = 6000;
        MenuDessin = 6001;
        MenuFichiers = 6002;
        MenuPr = 6004;
        SortieID = 9000;
        ErrfatID = 300;
        ErrFileID = 301;
        QbinaireID = 500;
        ErrNbID = 700;
        Enteteid = 800;
        NbBits = 32;
        NbBitsl1 = 31;
        IntBytes = 2;
        CarBytes = 2;
        PtrBytes = 4;
        BitsBytes = 4;
        BoolBytes = 1;
        LongBytes = 4;
        ReelBytes = 10;
        TrieBytes = 14;

    type
        EventSet = set of 0..inGoAway;
        Alpha = packed array[1..10] of Char;
        PtrFile = ^FileType;
        FileType = record
                FileNumber, VolNumber: Integer;
                vName: Boolean;
                Name: Str255;
            end;
        Ens = set of 0..NbBitsl1;
        Matrice = array[0..4] of Integer;
        Data = record
                case Integer of
                    1: (
                            Re: Extended
                    );
                    2: (
                            Int: Integer
                    );
                    3: (
                            Car: packed array[1..10] of Char
                    );
            end;
        DataFile = file of Data;
        Trie = record
                Resultat: Extended;
                PtrGauche, PtrDroit: Integer;
            end;
        TrieRec = record
                NoeudTrie: Trie;
            end;
        LongRec = record
                Long: LongInt;
            end;
        IntRec = record
                Int: Integer;
            end;
        IntType = ^IntRec;
        ReelRec = record
                Reel: Extended;
            end;
        ReelType = ^ReelRec;
        LongType = ^LongRec;
        BoolRec = record
                Bool: Boolean;
            end;
        BoolType = ^BoolRec;
        PtrRec = ^TrieRec;
        CarRec = record
                Car: Char;
            end;
        CarType = ^CarRec;
        BitsRec = record
                Bits: Ens;
            end;
        BitsType = ^BitsRec;
        InfoRec = record
                OffSet1, OffSet2, Rang, NbBytes: Integer;
            end;
        InfoPtr = ^InfoRec;
        idArray = record
                ID: packed array[1..10] of Char
            end;
        idType = ^idArray;
        PtrType = record
                case Integer of
                    1: (
                            PtrGen: Ptr
                    );
                    2: (
                            PtrInt: IntType
                    );
                    3: (
                            PtrRee: ReelType
                    );
                    4: (
                            PtrEnt: LongInt
                    );
                    5: (
                            PtrLong: LongType
                    );
                    6: (
                            PtrBool: BoolType
                    );
                    8: (
                            PtrBits: BitsType
                    );
                    9: (
                            PtrTrie: PtrRec
                    );
                    10: (
                            PtrCar: CarType
                    );
                    11: (
                            PtrInfo: InfoPtr
                    );
                    12: (
                            PtrID: idType
                    );
                    13: (
                            PtrStr: StringPtr
                    )
            end;
        FichierType = record
                Fichier: ^FileType;
                Delete: Boolean;
            end;

    procedure Entredessin (DessinModele: PicHandle;
                                    Ind1, Ind2: Integer);

    procedure CloseThings;

    procedure DeleteFich (var f: FileType);

    function MyFileFilter (ParamBlk: ParmBlkPtr): Boolean;

    function StringToReel (var Str: Str255): Extended;

    function Reel (i: Integer;
                                    Min, Max: Extended;
                                    StrDefault: StringPtr): Extended;

    function FilterForCursor (TheDialog: Dialogptr;
                                    var TheEvent: EventRecord;
                                    var Item: Integer): Boolean;

    procedure Dialoginit (Dialogtype: Integer);

    procedure Dialogue;

    procedure RetourneDialogue;

    procedure ErrNombre (i: Integer);

    function QuestionBinaire (i: Integer): Boolean;

    function StringToInteger (var Str: Str255;
                                    LimInf, LimSup: Integer): Integer;

    function Entier (i, LimInf, LimSup: Integer;
                                    St, StrDefault: StringPtr): Integer;

    procedure InitThings (AttendCRMouse: Boolean);

    function SilentDialog (TheDialog: Dialogptr;
                                    var TheEvent: EventRecord;
                                    var ItemHit: Integer): Boolean;

    procedure Erreurs (i, j, k: Integer;
                                    Fatal: Boolean);

    procedure StringToFile (var f: FileType;
                                    NoStr, Index, NbLn: Integer);

    procedure CreeSortie (var Sortie: FileType;
                                    Ind1, Ind2: Integer);

    procedure PrintSetup;

    procedure PrIntImage (Dessin: PicHandle;
                                    PrintRect: Rect;
                                    Setup: Boolean);

    procedure PrIntFichier (var Fich: FileType);

    procedure LisFich (Ind: Integer;
                                    var Entree: FileType;
                                    Stop: Boolean);

    procedure LisFichSimil (Ind: Integer;
                                    var Entree: FileType;
                                    Stop: Boolean);

    function LireString (i: Integer): Str255;

    procedure InitNelly (Notitle, Max: Integer);

    procedure MiseaJourd (l: Integer);

    procedure MiseaJourg (l: Integer);

    procedure NouveauDialogue (ID, j: Integer);

    procedure NextEvent (Quoi: EventSet);

    procedure ShowFichier (var Fich: FileType;
                                    Index: Integer;
                                    DessinCourant: PicHandle;
                                    R: Rect;
                                    ThereWasAWindow: Boolean);

    procedure Interruption;

    function LisReel (var t: FileType;
                                    Abort: Boolean): Extended;

    function LisEntier (var t: FileType;
                                    Abort: Boolean): LongInt;

    function LisID (var t: FileType;
                                    Abort: Boolean): Alpha;

    procedure ResetFile (t: FileType);

    function EndOfFile (var Fich: FileType): Boolean;

    function ReadCar (var Fich: FileType;
                                    Abort: Boolean): Char;

    function NextCar (var Fich: FileType;
                                    Abort: Boolean): Char;

    procedure Readlnf (var Fich: FileType);

    function ReadString (var Fich: FileType;
                                    Abort: Boolean): Str255;

    function ReelToString (x: Extended;
                                    Champ, Fraction: Integer): Str255;

    procedure WriteString (var Fich: FileType;
                                    Str: Str255);

    procedure WriteLnF (var Fich: FileType);

    procedure WriteCar (var Fich: FileType;
                                    Car: Char);

    procedure WriteSpaces (var Fich: FileType;
                                    NbSpaces: Integer);

    procedure WriteInteger (var Fich: FileType;
                                    Nb: LongInt;
                                    Format: Integer);

    procedure WriteReal (var Fich: FileType;
                                    Nb: Extended;
                                    Champ, Fraction: Integer);

    function GetReal (var t: FileType): Extended;

    function GetInteger (var t: FileType): Integer;

    function GetTri (var t: FileType): Trie;

    function NextTri (var t: FileType): Trie;

    procedure GetLn (var t: FileType);

    procedure PutReal (var t: FileType;
                                    x: Extended);

    procedure PutInteger (var t: FileType;
                                    x: Integer);

    procedure PutTri (var t: FileType;
                                    x: Trie);

    procedure FileErrHandler (var t: FileType);

    procedure TrouveFile (var t: FileType;
                                    Creator, FileType: OSType);

    function TrouveVolume: Integer;

    function Memoire (Min1, Max1, Min2, Max2, lgBytes: LongInt;
                                    Piege: Boolean): Ptr;

    procedure DisposeMemoire (var ThePtr: Ptr);

    function AdMat (p: Ptr;
                                    v1, v2: LongInt): PtrType;

    function AdVec (p: Ptr;
                                    v: LongInt): PtrType;

    function AdLin (p: Ptr;
                                    v1, v2: Integer): PtrType;

    function AdBits (mm: Ptr;
                                    i: Integer): PtrType;

    procedure Ajoute (Ind: Integer;
                                    mm: Ptr);

    function Card (x: Ens): Integer;

    function CardVect (m: Ptr): Integer;

    procedure Copy (m1, m2: Ptr);

    procedure Difference (m1, m2: Ptr);

    function Egal (m1, m2: Ptr): Boolean;

    procedure Enleve (Ind: Integer;
                                    mm: Ptr);

    function InclusEgal (m1, m2: Ptr): Boolean;

    procedure Intersection (m0, m1, m2: Ptr);

    function Membre (Ind: Integer;
                                    mm: Ptr): Boolean;

    procedure NullVec (m: Ptr);

    procedure Premier (var i: Integer;
                                    t: Ptr);

    procedure Union (m1, m2: Ptr);

    function Vide (m: Ptr): Boolean;

    var
        LisNombre, ErrNb, vPrinter, FichierSimil, Numeros: Boolean;
        TheDialog, TheCard, TheRef, TheOldDialog: Dialogptr;
        ItemHit, Printertype, MenuNum, MenuItem, NObjSimil, NbDescSimil, NbMots, Hauteur, Largeur, NbFiles, NbOpenFiles: Integer;
        MenuTyp, Ref: LongInt;
        Facteur: Extended;
        Str1, Str2, Str3, Str4, Str5, fTitre, TitreJob, TitreProg, TitreSimil: Str255;
        TextCursor, ClockCursor: CursHandle; {MacIntosh now on}
        Coord: Point;
        Sfr: SfReply;
        Sft: sfTypeList;
        Sortie: FileType;
        Date, Fonction: Alpha;
        AppleMenu, EditMenu, MenuHdl, MenuPrint, MenuFile: MenuHandle;
        ItemHandle1, ItemHandle2, ItemHandle3, ItemHandle4: Handle;
        Box: Rect;
        TheEvent: EventRecord;
        WindowPtr2: WindowPtr;
        AncienPort: GrafPtr;
        MyPrint: TpprPort;
        Finished, PrInter, Opennow, CloseNow: Boolean; { Set to true when were}
{                                                  done }
        ApplRefNum: Integer; { the resource file id of our appl }
        Header: StringHandle; { the text that goes into the Header }
        Footer: StringHandle; { dotto... for the footer }
        PgSetup: ThPrint; { handle to the page setup record }
        DessinCourant: PicHandle;
        MenuDessinHdl, MenuFichHdl: MenuHandle;
        RectAngleCourant: Rect;
        FileErr: OSErr;
        Count, CountByte, CountInteger, CountLongInt, CountReal, CountSimil: LongInt;
        FileArray: array[1..10] of FichierType;
        SilentAlert: ProcPtr;

implementation

    procedure Entredessin (DessinModele: PicHandle;
                                    Ind1, Ind2: Integer);

        var
            Zero: LongInt;
            i, GlobalRef: Integer;

    begin
        GetIndString(Str2, FichID, Ind1);
        GetIndString(Str1, FichID, Ind2);
        sfputfile(Coord, Str2, Str1, nil, Sfr);
        if Sfr.Good then begin
            FileErr := Create(Sfr.fName, Sfr.vRefNum, 'RPGR', 'PICT');
            if (FileErr = NoErr) | (FileErr = DupfnErr) then begin
                FileErr := fsOpen(Sfr.fName, Sfr.vRefNum, GlobalRef);
                Zero := 0;
                Count := 4;
                for i := 1 to 128 do
                    FileErr := fsWrite(GlobalRef, Count, @Zero);
                FileErr := SetfPos(GlobalRef, fsFromStart, 512); {skip the}
{            MacDraw header}
                Count := DessinModele^^.PicSize;
                FileErr := fsWrite(GlobalRef, Count, Ptr(DessinModele^));
                FileErr := fsClose(GlobalRef);
            end;
        end; {IF reply.good}
    end;

    procedure CloseThings;

        var
            i: Integer;
            FilePos: LongInt;

    begin
        if PrInter then begin
            FileErr := GetfPos(Sortie.FileNumber, FilePos);
            FileErr := SetEOF(Sortie.FileNumber, FilePos);
            PrIntFichier(Sortie);
        end;
        for i := 1 to NbFiles do begin
            with FileArray[i] do
                if Fichier^.vName then begin
                    if Delete then
                        DeleteFich(Fichier^)
                    else
                        FileErr := fsClose(Fichier^.FileNumber);
                end;
        end;
        Halt;
    end;

    function MyFileFilter (ParamBlk: ParmBlkPtr): Boolean;

        var
            Str1, Str2: Str255;

    begin
        with ParamBlk^ do begin
            MyFileFilter := IOfRefNum <> 0;
        end;
{ Mod. PhC 11/02/98: utiliser ceci pour avoir la liste de tous les fichiers en tout temps }
{$ifc false}
        MyFileFilter := false; { show all files }
{$endc}
    end;

    procedure ErrFile (i: Integer;
                                    var t: FileType);

    begin
        GetIndString(Str1, ErrFileID, i);
        ParamText(Str1, '', t.Name, '');
        i := StopAlert(ErrFileID, nil);
        CloseThings;
    end; { fin erreur }

    procedure FileErrHandler (var t: FileType);

        var
            j: Integer;

    begin
        if FileErr <> 0 then begin
            FileErr := -FileErr;
            if FileErr >= 50 then begin
                j := FileErr - 33;
            end
            else begin
                if FileErr > 43 then begin
                    j := FileErr - 32;
                end
                else begin
                    if FileErr = 42 then begin
                        j := 11;
                    end
                    else begin
                        if FileErr >= 33 then begin
                            j := FileErr - 30
                        end
                        else begin
                            j := 28;
                        end;
                    end;
                end;
            end;
            ErrFile(j, t);
            FileErr := -FileErr;
        end;
    end;

    procedure ResetFile (t: FileType);

    begin
        FileErr := SetfPos(t.FileNumber, fsFromStart, 0);
        FileErrHandler(t);
    end;

    function EndOfFile (var Fich: FileType): Boolean;

        var
            FilePos, LogEOF: LongInt;

    begin
        with Fich do begin
            FileErr := GetEOF(FileNumber, LogEOF);
            FileErr := GetfPos(FileNumber, FilePos);
        end;
        EndOfFile := LogEOF = FilePos;
    end;

    function ReelToString (x: Extended;
                                    Champ, Fraction: Integer): Str255;

        var
            f: DecForm;
            s: DecStr;

    begin
        f.Style := FixedDecimal;
        f.Digits := Fraction;
        Num2Str(f, x, s);
        if Champ > 0 then begin
            if Length(s) > Champ then begin
                f.Style := FloatDecimal;
                Num2Str(f, x, s);
                if Length(s) > Champ then begin
                    f.Style := FloatDecimal;
                    f.Digits := f.Digits + Champ - Length(s);
                    Num2Str(f, x, s);
                end;
            end;
        end;
        ReelToString := s;
    end;

    function ReadCar (var Fich: FileType;
                                    Abort: Boolean): Char;

        var
            CarInt: Integer;
            Count: LongInt;

    begin
        if EndOfFile(Fich) then begin
            if (Abort) then
                ErrFile(1, Fich);
        end
        else begin
            Count := 1;
            FileErr := fsRead(Fich.FileNumber, Count, @CarInt);
            ReadCar := Chr(CarInt div 256);
        end;
    end;

    function NextCar (var Fich: FileType;
                                    Abort: Boolean): Char;

        var
            CarInt: Integer;
            Count, CurrentPos: LongInt;

    begin
        if EndOfFile(Fich) then begin
            if (Abort) then
                ErrFile(1, Fich);
        end
        else begin
            FileErr := GetfPos(Fich.FileNumber, CurrentPos);
            Count := 1;
            FileErr := fsRead(Fich.FileNumber, Count, @CarInt);
            FileErr := SetfPos(Fich.FileNumber, 1, CurrentPos);
            NextCar := Chr(CarInt div 256);
        end;
    end;

    procedure Readlnf (var Fich: FileType);

        var
            GenCar: Char;

    begin
        if EndOfFile(Fich) then
            GenCar := Chr(13)
        else
            GenCar := ReadCar(Fich, True);
        while (not (EndOfFile(Fich))) and (Ord(GenCar) <> 13) do
            GenCar := ReadCar(Fich, True);
    end;

    function ReadString (var Fich: FileType;
                                    Abort: Boolean): Str255;

        var
            Count, CurrentPos, LinePos, StrLength: LongInt;
            CarInt: Integer;
            Str: Str255;

    begin
        if (EndOfFile(Fich)) and (Abort) then
            ErrFile(1, Fich);
        Str := '';
        StrLength := 0;
        Count := 1;
        FileErr := GetfPos(Fich.FileNumber, CurrentPos);
        repeat
            FileErr := fsRead(Fich.FileNumber, Count, @CarInt);
            StrLength := StrLength + 1;
        until (Count = 0) or (CarInt div 256 = 13);
        FileErr := GetfPos(Fich.FileNumber, LinePos);
        FileErr := SetfPos(Fich.FileNumber, 1, CurrentPos);
        FileErr := fsRead(Fich.FileNumber, StrLength, @Str[1]);
        if Count = 1 then
            StrLength := StrLength - 1; { EOLN }
        Str[0] := Chr(StrLength);
        ReadString := Str;
    end;

    procedure WriteString (var Fich: FileType;
                                    Str: Str255);

    begin
        Count := Length(Str);
        FileErr := fsWrite(Fich.FileNumber, Count, @Str[1]);
    end;

    procedure WriteCar (var Fich: FileType;
                                    Car: Char);

        var
            CarInt: Integer;

    begin
        Count := 1;
        CarInt := Ord(Car) * 256;
        FileErr := fsWrite(Fich.FileNumber, Count, @CarInt);
    end;

    procedure WriteSpaces (var Fich: FileType;
                                    NbSpaces: Integer);

        var
            i, SpaceCode: Integer;

    begin
        SpaceCode := 8192; { Attention Bug adressage TML: devrait etre 32 au}
{                      lieu de 8192(32x256 }
        Count := 1;
        for i := 1 to NbSpaces do
            FileErr := fsWrite(Fich.FileNumber, Count, @SpaceCode);
    end;

    procedure WriteLnF (var Fich: FileType);

        var
            crCode: Integer;

    begin
        crCode := 3328; { Attention Bug adressage TML: devrait etre 13 au lieu}
{                   de 3328(13x256 }
        Count := 1;
        FileErr := fsWrite(Fich.FileNumber, Count, @crCode);
    end;

    procedure WriteInteger (var Fich: FileType;
                                    Nb: LongInt;
                                    Format: Integer);

        var
            i: Integer;

    begin
        NumToString(Nb, Str1);
        i := Length(Str1);
        WriteSpaces(Fich, Format - i);
        Count := i;
        FileErr := fsWrite(Fich.FileNumber, Count, @Str1[1]);
    end;

    procedure WriteReal (var Fich: FileType;
                                    Nb: Extended;
                                    Champ, Fraction: Integer);

        var
            s: Str255;
            i: Integer;

    begin
        s := ReelToString(Nb, Champ, Fraction);
        i := Length(s);
        WriteSpaces(Fich, Champ - i);
        Count := i;
        FileErr := fsWrite(Fich.FileNumber, Count, @s[1]);
    end;

    procedure StringToFile (var f: FileType;
                                    NoStr, Index, NbLn: Integer);

        var
            i, crCode: Integer;
            Count: LongInt;

    begin
        GetIndString(Str1, NoStr, Index);
        Count := Length(Str1);
        FileErr := fsWrite(f.FileNumber, Count, @Str1[1]);
        CountByte := 1;
        for i := 1 to NbLn do
            WriteLnF(f);
    end;

    function SilentDialog (TheDialog: Dialogptr;
                                    var TheEvent: EventRecord;
                                    var ItemHit: Integer): Boolean;

        var
            NbTicks: LongInt;

    begin
        SystemTask; { Take care of desk accessories }
        DrawDialog(TheDialog);
        NbTicks := TickCount;
        repeat { do this until we selected quit}
        until TickCount - NbTicks > 100; { end of repeat statement }
        SilentDialog := True;
    end;

    procedure Erreurs (i, j, k: Integer;
                                    Fatal: Boolean);

    begin
        GetIndString(Str1, ErrfatID, i);
        Str3 := '';
        Str4 := '';
        if j > 0 then begin
            NumToString(j, Str3);
            if k > 0 then
                NumToString(k, Str4);
        end;
        ParamText(Str1, '', Str3, Str4);
        if Fatal then begin
            i := StopAlert(ErrfatID, nil);
            CloseThings;
        end
        else
            i := CautionAlert(ErrfatID, SilentAlert);
        ResetAlertStage;
    end; { fin erreur }

    function GetReal (var t: FileType): Extended;

        var
            x: Extended;

    begin
        Count := ReelBytes;
        FileErr := fsRead(t.FileNumber, Count, @x);
        GetReal := x;
    end;

    function GetInteger (var t: FileType): Integer;

        var
            i: Integer;

    begin
        Count := IntBytes;
        FileErr := fsRead(t.FileNumber, Count, @i);
        GetInteger := i;
    end;

    function GetTri (var t: FileType): Trie;

        var
            tt: Trie;

    begin
        Count := TrieBytes;
        FileErr := fsRead(t.FileNumber, Count, @tt);
        GetTri := tt;
    end;

    function NextTri (var t: FileType): Trie;

        var
            tt: Trie;

    begin
        Count := TrieBytes;
        FileErr := fsRead(t.FileNumber, Count, @tt);
        NextTri := tt;
        FileErr := SetfPos(t.FileNumber, fsFromMark, -Count);
    end;

    procedure GetLn (var t: FileType);

        var
            i: Integer;

    begin
        Count := 1;
        repeat
            FileErr := fsRead(t.FileNumber, Count, @i);
            if FileErr <> 0 then
                FileErrHandler(t);
        until (i div 256 = 13);
    end;

    procedure PutReal (var t: FileType;
                                    x: Extended);

    begin
        Count := ReelBytes;
        FileErr := fsWrite(t.FileNumber, Count, @x);
    end;

    procedure PutInteger (var t: FileType;
                                    x: Integer);

    begin
        Count := IntBytes;
        FileErr := fsWrite(t.FileNumber, Count, @x);
    end;

    procedure PutTri (var t: FileType;
                                    x: Trie);

    begin
        Count := TrieBytes;
        FileErr := fsWrite(t.FileNumber, Count, @x);
    end;

    function TrouveVolume: Integer;

        var
            Necessaire, Free: LongInt;
            j, jj: Integer;
            DrivePtr: QHdrPtr;
            ElemPtr: QElemPtr;

    begin
{ Procédure modifiée 25/05/98 par PhC, rendue inopérante pour CW }
        jj := 0;
{$ifc not undefined THINK_PASCAL}
        DrivePtr := GetDrvqHdr;
        ElemPtr := DrivePtr^.QHead;
        Necessaire := 0;
        repeat
            with ElemPtr^.DrvqElem do begin
                FileErr := GetVInfo(dqDrive, @Str1, j, Free);
                if FileErr = 0 then begin
                    if Free > Necessaire then begin
                        Necessaire := Free;
                        jj := j;
                    end;
                end;
            end;
            ElemPtr := ElemPtr^.DrvqElem.QLink;
        until ElemPtr = nil;
{$endc}
        TrouveVolume := jj;
    end;

    procedure TrouveFile (var t: FileType;
                                    Creator, FileType: OSType);

        label
            777;

        var
            i3, i4, i5: Integer;

    begin
        t.Name := 'ZZZZZ';
        for i3 := 26 downto 1 do begin
            t.Name[3] := Chr(64 + i3);
            for i4 := 26 downto 1 do begin
                t.Name[4] := Chr(64 + i4);
                for i5 := 26 downto 1 do begin
                    t.Name[5] := Chr(64 + i5);
                    FileErr := Create(t.Name, t.VolNumber, Creator, FileType);
                    if FileErr = 0 then
                        goto 777;
                end;
            end;
        end;
777:
        with t do
            FileErr := fsOpen(Name, VolNumber, FileNumber);
        NbFiles := NbFiles + 1;
        with FileArray[NbFiles] do begin
            Delete := True;
            Fichier := @t;
        end;
        FileErrHandler(t);
        t.vName := True;
    end;

    procedure InitThings (AttendCRMouse: Boolean);

    begin
        MaxApplZone;
{$ifc undefined THINK_PASCAL}
        InitGraf(@qd.ThePort);
{$elsec}
        InitGraf(@ThePort);
{$endc}
        MoreMasters;
        MoreMasters;
        MoreMasters;
        MoreMasters;
        MoreMasters;
        MoreMasters;
        MoreMasters;
        ClockCursor := GetCursor(WatchCursor);
        TextCursor := GetCursor(iBeamCursor);
        hLock(Handle(ClockCursor));
        hLock(Handle(TextCursor));
        SetCursor(ClockCursor^^);
        InitFonts;
        InitWindows;
        InitMenus;
        TEInit;
        InitDialogs(nil);
        FlushEvents(EveryEvent, 0);
        AppleMenu := GetMenu(AppleID);
        TextFont(SystemFont);
        SetMenuItemText(AppleMenu, 0, Chr(20));
        EditMenu := GetMenu(EditID);
        MenuHdl := GetMenu(MenuID);
        AppendResMenu(AppleMenu, 'DRVR'); { Add desk accessories }
        InsertMenu(AppleMenu, 0);
        MenuFile := GetMenu(FileMenuID);
        InsertMenu(MenuFile, 0);
        DisableItem(MenuFile, 2);
        InsertMenu(EditMenu, 0);
        InsertMenu(MenuHdl, 0);
        DisableItem(MenuHdl, 2);
        DrawMenubar;
        InitCursor;
        TheCard := GetNewDialog(CardID, nil, Pointer(-1));
        if AttendCRMouse then
            repeat
                ModalDialog(nil, ItemHit);
            until ItemHit = ok;
{ Mod. PhC 11/02/98: cette instruction crashe le PowerPC... }
{    ClipRect(ScreenBits.Bounds);}
        Sortie.vName := False;
        vPrinter := False;
        DrawMenubar;
        TitreProg := '';
        FichierSimil := False;
        fTitre := '';
        NObjSimil := 0;
        NbDescSimil := 0;
        CountByte := 1;
        CountInteger := 2;
        CountLongInt := 4;
        CountReal := 10;
        CountSimil := 10;
        PrInter := False;
        PgSetup := nil;
        SilentAlert := nil;
    end;

    procedure DeleteFich (var f: FileType);

        var
            i: Integer;

    begin
        with f do begin
            FileErr := fsClose(FileNumber);
            if FileErr = 0 then
                FileErr := fsDelete(Name, VolNumber);
        end;
    end;

    function FilterForCursor (TheDialog: Dialogptr;
                                    var TheEvent: EventRecord;
                                    var Item: Integer): Boolean;

        const
            crCode = 13;
            Entercode = 3; {ASCII ccode for ENTER}
            SpaceCode = 32;

        var
            MouseLocation: Point;
            ItemHandle: Handle;
            Opttype, Car: Integer;
            TextBox: Rect;

    begin
        FilterForCursor := False;
        Item := 0;
        GetDialogItem(TheDialog, 3, Opttype, ItemHandle, TextBox);
        case TheEvent.What of
            NullEvent:  begin
                GetMouse(MouseLocation);
                if PtInrect(MouseLocation, TextBox) then
                    SetCursor(TextCursor^^)
                else
{$ifc undefined THINK_PASCAL}
                    SetCursor(qd.Arrow);
{$elsec}
                SetCursor(Arrow);
{$endc}
            end;

            KeyDown, AutoKey: {to follow std. PROCEDURE, chk if RETURN or ENTER}
{                       was pressed}
                begin
                Car := TheEvent.Message mod 256;
                if ((Car = crCode) or (Car = Entercode)) or ((LisNombre) and (Car = SpaceCode)) then begin
                    FilterForCursor := True;
                    Item := 1;
                end;
            end;
{ Mod. PhC 11/02/98: case selector out of range }
            otherwise
                ;
        end; {of the CASE statment}
    end;

    procedure Dialoginit (Dialogtype: Integer);

    begin
        GetPort(AncienPort);
        TheDialog := GetNewDialog(Dialogtype, nil, Pointer(-1));
        SetPort(TheDialog);
    end;

    procedure Dialogue;

        var
            ItemType: Integer;
            BoxHandle: Handle;
            Box: Rect;

    begin
        repeat
            ModalDialog(@FilterForCursor, ItemHit);
        until ItemHit = ok;
        GetDialogItem(TheDialog, 3, ItemType, BoxHandle, Box);
        GetDialogItemText(BoxHandle, Str5);
{$ifc undefined THINK_PASCAL}
        SetCursor(qd.Arrow);
{$elsec}
        SetCursor(Arrow);
{$endc}
    end;

    procedure RetourneDialogue;

    begin
        DisposeDialog(TheDialog);
        SetPort(AncienPort);
    end;

    function QuestionBinaire (i: Integer): Boolean;

    begin
        GetIndString(Str1, QbinaireID, i);
        ParamText(Str1, '', '', '');
        QuestionBinaire := (Alert(QbinaireID, nil) = 1);
    end;

    procedure ErrNombre (i: Integer);

        var
            ItemType: Integer;
            ItemHandle: Handle;
            DispRect: Rect;

    begin
        GetIndString(Str2, ErrNbID, i);
        ErrNb := True;
        GetDialogItem(TheDialog, 5, ItemType, ItemHandle, DispRect);
        SetDialogItemText(ItemHandle, Str2);
    end;

    function StringToInteger (var Str: Str255;
                                    LimInf, LimSup: Integer): Integer;

        var
            i, Nb, Longueur, Debut, Facteur, Car: Integer;
            Negatif: Boolean;

    begin
        Nb := 0;
        Longueur := Length(Str);
        Facteur := 1;
        Negatif := False;
        Debut := 1;
        if Str[1] = '-' then begin
            Debut := 2;
            Negatif := True;
        end
        else if Str[1] = '+' then
            Debut := 2;
        for i := Longueur downto Debut do begin
            Car := Ord(Str[i]) - Ord('0');
            if (Car < 0) or (Car > 9) then
                ErrNombre(1)
            else begin
                Nb := Nb + Facteur * Car;
                Facteur := Facteur * 10;
            end;
        end;
        if Negatif then
            Nb := -Nb;
        if (Nb < LimInf) or (Nb > LimSup) then
            ErrNombre(2)
        else
            StringToInteger := Nb;
    end;

    function Entier (i, LimInf, LimSup: Integer;
                                    St, StrDefault: StringPtr): Integer;

        var
            j: LongInt;
            Debut, Opttype: Integer;
            ItemHandle: Handle;
            TextBox: Rect;

    begin
        LisNombre := True;
        GetIndString(Str1, IntID, i);
        ParamText(Str1, '', St^, '');
        Dialoginit(ReelID);
        if StrDefault <> nil then begin
            GetDialogItem(TheDialog, 3, Opttype, ItemHandle, TextBox);
            SetDialogItemText(ItemHandle, StrDefault^);
            SelectDialogItemText(TheDialog, 3, 0, Length(StrDefault^)); { select it }
        end;
        repeat
            ErrNb := False;
            Dialogue;
            j := StringToInteger(Str5, LimInf, LimSup);
        until not (ErrNb);
        Debut := 1;
        while Str5[Debut] in [' ', ' '] do
            Debut := Debut + 1;
        if Str5[Debut] = '-' then
            j := -j;
        RetourneDialogue;
        Entier := j;
    end;

    function StringToReel (var Str: Str255): Extended;

        var
{$ifc undefined THINK_PASCAL}
            ValidPrefix: Integer;
{$elsec}
            ValidPrefix: Boolean;
{$endc}
            s: DecStr;
            Index: Integer;
            d: Decimal;
            Ff: record
                    case Boolean of
                        True: (
                                f: Extended
                        );
                        False: (
                                R: Extended
                        );
                end;

    begin
        Index := 1;
        s := Str;
{$ifc undefined THINK_PASCAL}
        Str2Dec(@s, Index, d, ValidPrefix);
{$elsec}
        Str2Dec(s, Index, d, ValidPrefix);
{$endc}
        if not Boolean(ValidPrefix) then
            ErrNombre(1);
        Ff.f := Str2Num(s);
        StringToReel := Ff.R;
    end;

    function Reel (i: Integer;
                                    Min, Max: Extended;
                                    StrDefault: StringPtr): Extended;

        var
            Val: Extended;
            ItemHandle: Handle;
            TextBox: Rect;
            Opttype: Integer;

    begin
        LisNombre := True;
        GetIndString(Str1, ReelID, i);
        ParamText(Str1, '', '', '');
        Dialoginit(ReelID);
        if StrDefault <> nil then begin
            GetDialogItem(TheDialog, 3, Opttype, ItemHandle, TextBox);
            SetDialogItemText(ItemHandle, StrDefault^);
            SelectDialogItemText(TheDialog, 3, 0, Length(StrDefault^)); { select it }
        end;
        repeat
            ErrNb := False;
            Dialogue;
            Val := StringToReel(Str5);
            if (Val < Min) or (Val > Max) then
                ErrNombre(2);
        until not (ErrNb);
        Reel := Val;
        RetourneDialogue;
    end;

    procedure PrintSetup;

        var
            TrueOrFalse: Boolean;
            DumpgSetup: TPrint;

    begin
        PrOpen;
        if PgSetup <> nil then begin
            hUnlock(Handle(PgSetup));
            DisposeHandle(Handle(PgSetup));
        end;
        PgSetup := ThPrint(NewHandle(SizeOf(DumpgSetup))); {make handle}
        PrIntDefault(PgSetup); {initialize the fields}
        hLock(Handle(PgSetup));
        InitCursor;
        TrueOrFalse := PrValidate(PgSetup); { make sure handle is valid}
        TrueOrFalse := PrStlDialog(PgSetup); { fill the record with the info}
        InitCursor;
        PrClose;
    end;

    procedure CreeSortie (var Sortie: FileType;
                                    Ind1, Ind2: Integer);

        label
            777;

        var
            j, k: Integer;

    begin
        Coord.h := 50;
        Coord.v := 50;
        GetIndString(Str2, FichID, Ind1);
        GetIndString(Str1, FichID, Ind2);
        sfputfile(Coord, Str2, Str1, nil, Sfr);
        with Sfr do begin
            if not (Good) then
                CloseThings
            else begin
777:
                FileErr := Create(fName, vRefNum, 'R*ch', 'TEXT');
                if FileErr = DupfnErr then begin
                    FileErr := fsDelete(fName, vRefNum);
                    goto 777;
                end;
                FileErrHandler(Sortie);
                FileErr := fsOpen(fName, vRefNum, Sortie.FileNumber);
                FileErrHandler(Sortie);
                with Sortie do begin
                    vName := True;
                    Name := fName;
                    VolNumber := vRefNum;
                    NbFiles := NbFiles + 1;
                    with FileArray[NbFiles] do begin
                        Delete := False;
                        Fichier := @Sortie;
                    end;
                end;
            end;
        end;
    end;

{--------------------------- set the page setup info ---------------------------}

    function DoSetup: Boolean;

        var
            TrueOrFalse, PrNonValide: Boolean;
            DumpgSetup: TPrint;

    begin
        InitCursor;
        if PgSetup = nil then begin
            PgSetup := ThPrint(NewHandle(SizeOf(DumpgSetup))); {make handle}
            PrIntDefault(PgSetup); {initialize the fields}
            hLock(Handle(PgSetup));
        end;
        PrNonValide := PrValidate(PgSetup); { make sure handle is valid}
        if PrNonValide then
            TrueOrFalse := PrStlDialog(PgSetup) { fill the record with the info}
        else
            TrueOrFalse := True;
        InitCursor;
        DoSetup := (TrueOrFalse);
    end;

{-------------------------- get and print the document -------------------------}

    procedure DoPrint (var f: FileType;
                                    Dessin: PicHandle;
                                    DessinRect: Rect;
                                    Setup: Boolean);

        var
{$ifc undefined THINK_PASCAL}
            MyPrPort: TpprPortRef;
{$elsec}
            MyPrPort: TpprPort;
{$endc}
            Mystrec: TprStatus;
            Pg, Largeur: Integer;
            Done: Boolean;
            PgWidth, PgHeight, CurrentLine, NumLines, BaseLine, NumSpacesInTab, Index: Integer;
            Facteur: Extended;
            GotIt, Toto: Boolean;
            TabStarts: array[1..30] of Integer;
            PenPoint: Point;
            Count: Integer;
            Secs: LongInt;
            Date: DateTimeRec;

    begin { DOPRINT }
        InitCursor;
        if Setup then
            Toto := PrJobDialog(PgSetup)
        else
            Toto := True;
        if Toto then {print the document}
            begin
            SetCursor(ClockCursor^^);
            MyPrPort := PrOpenDoc(PgSetup, nil, nil);
            Pg := 1;
            GetDateTime(Secs);
            SecondsToDate(Secs, Date);
            NumToString(Date.Month, Str2);
            Str1 := Concat(TitreProg, '    ', Str2, '/');
            NumToString(Date.Day, Str2);
            Str1 := Concat(Str1, Str2, '/');
            NumToString(Date.Year - 1900, Str2);
            Str1 := Concat(Str1, Str2, '    ');

            NumToString(Date.Hour, Str2);
            Str1 := Concat(Str1, Str2, ':');
            NumToString(Date.Minute, Str2);
            Str1 := Concat(Str1, Str2, ':');
            NumToString(Date.Second, Str2);
            if Date.Second < 10 then
                Str1 := Concat(Str1, '0', Str2)
            else
                Str1 := Concat(Str1, Str2);
            if Dessin <> nil then
                Done := True
            else begin
                Done := False;
          {width in pixels}
{$ifc undefined THINK_PASCAL}
                PgWidth := system.Round(((PgSetup^^.PrInfo.RPage.Right) / (PgSetup^^.PrInfo.ihRes)) * 72);
{$elsec}
                PgWidth := Round(((PgSetup^^.PrInfo.RPage.Right) / (PgSetup^^.PrInfo.ihRes)) * 72);
{$endc}

          {height in pixels}
{$ifc undefined THINK_PASCAL}
                PgHeight := system.Round(((PgSetup^^.PrInfo.RPage.Bottom) / (PgSetup^^.PrInfo.ivres)) * 72);
{$elsec}
                PgHeight := Round(((PgSetup^^.PrInfo.RPage.Bottom) / (PgSetup^^.PrInfo.ivres)) * 72);
{$endc}

                BaseLine := 12;

                NumLines := (PgHeight div BaseLine) - 4; { get the number of}
{                                                    lines}

                ResetFile(f);
            end;

            repeat
                if PrError = NoErr then begin
                    PrOpenPage(MyPrPort, nil); { start new page}
                    if PrError = NoErr then begin
                        if Dessin = nil then begin
                            CurrentLine := 1;

                            TextFont(4); { monaco = 4 }
                            TextSize(9);
                            NumSpacesInTab := 8;

                            for Index := 1 to 30 do { initialize tab starts}
{                                             array}
                                TabStarts[Index] := (CharWidth(Chr($20)) * NumSpacesInTab * Index) + 20;

                    {Draw Header}
                            TextFace([Bold]);
                            MoveTo(20, CurrentLine * BaseLine);
                            NumToString(Pg, Str2);
                            DrawString(Concat(Str1, '         Page ', Str2));
                            CurrentLine := CurrentLine + 1;
                            MoveTo(20, CurrentLine * BaseLine);
                            DrawString(TitreJob);
                            TextFace([]);

                            CurrentLine := CurrentLine + 2;

                    {Draw lines of page}
                            for CurrentLine := CurrentLine to NumLines + 2 do
                                if not Done then begin
                                    Str3 := ReadString(f, True);
                                    MoveTo(20, CurrentLine * BaseLine);
                                    for Index := 1 to Length(Str3) do begin
                                        if Str3[Index] = Chr($9) then {tab}
                                            begin
                                            GetPen(PenPoint);
                                            Count := 1;
                                            GotIt := False;
                                            repeat
                                                if PenPoint.h >= TabStarts[Count] then
                                                    Count := Count + 1
                                                else begin
                                                    GotIt := True;
                                                    MoveTo(TabStarts[Count], PenPoint.v);
                                                end;
                                            until GotIt;
                                        end
                                        else
                                            DrawString(Str3[Index]);
                                    end;
                                    if EndOfFile(f) then
                                        Done := True;
                                end;

                    {Draw Footer}
                            CurrentLine := CurrentLine + 2;
                            TextFace([]);
                        end
                        else begin
                            TextFace([Bold]);
                            MoveTo(20, 20);
                            DrawString(Str1);
                            MoveTo(20, 40);
                            DrawString(TitreJob);
                            TextFace([]);
                            with DessinRect do begin
                        {Facteur:=(PgSetUp^^.prInfo.rPage.Right-20)}
{                            /(ScreenBits.Bounds.Right);}
{                        Right:=Round(Right*Facteur)+20;}
{                        Bottom:=Round((Bottom-Top) * Facteur)+41;}
                                Largeur := Right - Left;
                                if Right > PgSetup^^.PrInfo.RPage.Right - 20 then
                                    Right := PgSetup^^.PrInfo.RPage.Right - 20;
                                Left := 20;
                                Facteur := (Right - Left) / Largeur;
                                Facteur := (PgSetup^^.PrInfo.ivres) / (PgSetup^^.PrInfo.ihRes) * Facteur;
{$ifc undefined THINK_PASCAL}
                                Bottom := system.Round((Bottom - Top) * Facteur);
{$elsec}
                                Bottom := Round((Bottom - Top) * Facteur);
{$endc}
                                Top := 61;
                                Bottom := Bottom + Top;
                            end;
                            DrawPicture(Dessin, DessinRect);
                        end;
                    end;
                    PrClosePage(MyPrPort);
                end;
                Pg := Pg + 1;
            until ((PrError <> NoErr) or (Done));

            PrCloseDoc(MyPrPort);
            if (PgSetup^^.PrJob.Bjdocloop = bSpoolLoop) and (PrError = NoErr) then
{$ifc undefined THINK_PASCAL}
                PrPicFile(PgSetup, nil, nil, nil, @Mystrec);
{$elsec}
            PrPicFile(PgSetup, nil, nil, nil, Mystrec);
{$endc}
            if PrError <> NoErr then
                SysBeep(1);
        end;
    end;

{----------------------- initialize the page setup record ----------------------}

    procedure InitPage;

        var
            DumpgSetup: TPrint;

    begin
        PgSetup := ThPrint(NewHandle(SizeOf(DumpgSetup))); {make handle}
        PrIntDefault(PgSetup); {initialize the fields}
        hLock(Handle(PgSetup));
    end;

    procedure PrIntImage (Dessin: PicHandle;
                                    PrintRect: Rect;
                                    Setup: Boolean);

    begin
        PrOpen;
        vPrinter := True;
        if DoSetup then
            DoPrint(Sortie, Dessin, PrintRect, Setup);
        InitCursor;
        HiliteMenu(0);
        PrClose;
    end;

    procedure PrIntFichier (var Fich: FileType);

        var
            R: Rect;

    begin
        PrOpen;
        vPrinter := True;
        SetCursor(ClockCursor^^);
  {if not(VPrinter) then PrintInit;}
        SetRect(R, 0, 0, 0, 0);
        if DoSetup then
            DoPrint(Fich, nil, R, True);
        InitCursor;
        PrClose;
    end;

    procedure LisFich (Ind: Integer;
                                    var Entree: FileType;
                                    Stop: Boolean);

    begin
        GetIndString(Str1, FichID, Ind);
        ParamText(Str1, '', '', '');
        Dialoginit(FichID);
        DrawDialog(TheDialog);
        Coord.h := 50;
        Coord.v := 50;
        Sft[0] := 'TEXT';
        sfGetFile(Coord, Str1, @MyFileFilter, 1, @Sft, nil, Sfr);
        with Sfr do begin
            if not (Good) then begin
                if Stop then
                    CloseThings;
            end
            else begin
                fTitre := fName;
                FileErr := fsOpen(fName, vRefNum, Entree.FileNumber);
                FileErrHandler(Entree);
                Entree.VolNumber := vRefNum;
                ResetFile(Entree);
                Entree.vName := True;
                Entree.Name := fName;
                NbFiles := NbFiles + 1;
                with FileArray[NbFiles] do begin
                    Delete := False;
                    Fichier := @Entree;
                end;
            end;
        end;
        RetourneDialogue;
    end;

    procedure LisFichSimil (Ind: Integer;
                                    var Entree: FileType;
                                    Stop: Boolean);

    begin
        GetIndString(Str1, FichID, Ind);
        ParamText(Str1, '', '', '');
        Dialoginit(FichID);
        DrawDialog(TheDialog);
        Coord.h := 50;
        Coord.v := 50;
        Sft[0] := 'RSIM';
        sfGetFile(Coord, Str1, @MyFileFilter, 1, @Sft, nil, Sfr);
        with Sfr do begin
            if not (Good) then begin
                if Stop then
                    CloseThings;
            end
            else begin
                fTitre := fName;
                FileErr := fsOpen(fName, vRefNum, Entree.FileNumber);
                FileErrHandler(Entree);
                Entree.VolNumber := vRefNum;
                ResetFile(Entree);
                Entree.vName := True;
                Entree.Name := fName;
                NbFiles := NbFiles + 1;
                with FileArray[NbFiles] do begin
                    Delete := False;
                    Fichier := @Entree;
                end;
            end;
        end;
        RetourneDialogue;
    end;

    function LireString (i: Integer): Str255;

    begin
        LisNombre := False;
        GetIndString(Str1, TitreID, i);
        ParamText(Str1, '', '', '');
        Dialoginit(TitreID);
        Dialogue;
        RetourneDialogue;
        LireString := Str5;
    end;

    procedure InitNelly (Notitle, Max: Integer);

        var
            i: Integer;

    begin
        Dialoginit(NellyID);
        if Notitle <> 0 then
            GetIndString(Str1, NellyID, Notitle);
        SetwTitle(TheDialog, Str1);
        GetDialogItem(TheDialog, 1, i, ItemHandle1, Box);
        GetIndString(Str1, NellyID, 1);
        SetDialogItemText(ItemHandle1, Str1);
        GetDialogItem(TheDialog, 2, i, ItemHandle2, Box);
        GetIndString(Str1, NellyID, 2);
        SetDialogItemText(ItemHandle2, Str1);
        GetDialogItem(TheDialog, 3, i, ItemHandle3, Box);
        GetDialogItem(TheDialog, 4, i, ItemHandle4, Box);
        NumToString(Max, Str1);
        SetDialogItemText(ItemHandle3, Str1);
        DrawDialog(TheDialog);
    end;

    procedure NouveauDialogue (ID, j: Integer);

    begin
        GetIndString(Str1, ID, j);
        Dialoginit(ID);
        GetDialogItem(TheDialog, 1, j, ItemHandle1, Box);
        SetDialogItemText(ItemHandle1, Str1);
    end;

    procedure ProcessMenu (CodeWord: LongInt);

        var
            NameHolder: Str255; { the name of the desk acc. }
            Dummy: Integer; { just a dummy }
            OldPort: GrafPtr;

    begin
        MenuNum := HiWord(CodeWord); { get the menu number }
        MenuItem := LoWord(CodeWord); { get the item number }
        if (MenuItem > 0) and (MenuNum < 6000) then { ok to handle the menu? }
            begin
            case MenuNum of
                AppleID:  begin
                    GetMenuItemText(AppleMenu, MenuItem, NameHolder);
                    GetPort(OldPort);
                    Dummy := Opendeskacc(NameHolder);
                    SetPort(OldPort);
                end;
                EditID:  begin
                    if not SystemEdit(MenuItem - 1) then begin
                    end;
                end;
                FileMenuID:  begin
                    case MenuItem of
                        0:  begin
                        end;
                        1:
                            Opennow := True;
                        2:
                            CloseNow := True;
                        3:
                            PrintSetup;
                    end; {MenuItem}
                end;

                otherwise begin
                end;
            end; { of case menuNum of }
            MenuNum := 0;
            MenuItem := 0;
        end
        else if (MenuNum = 6000) and (MenuItem = 1) then
            CloseThings
        else if MenuItem = 0 then
            MenuNum := 0;
        HiliteMenu(0);
    end; { of process menu }

    procedure Interruption;

    begin
        repeat
            NextEvent([InDesk, inMenuBar, Insyswindow, InContent, InDrag, inGrow, inGoAway]);
        until FrontWindow = TheDialog;
        DrawDialog(TheDialog);
    end;

    procedure NextEvent (Quoi: EventSet);

        type
            TrickType = packed record { to get around pascal's typing }
                    case Boolean of
                        True: (
                                i: LongInt
                        );
                        False: (
                                Chr3, Chr2, Chr1, Chr0: Char
                        );
                end;

        var
            WindowLoc: Integer; { the mouse location }
            MouseLoc: Point; { the area it was in }
            TheWindow: WindowPtr; { Dummy,cause we have no windows}
            TrickVar: TrickType; { because of pascal's typing }
            CharCode: Char; { for command keys }

    begin
        Opennow := False;
        CloseNow := False;
        WindowLoc := -1;
        repeat { do this until we selected quit}
            SystemTask; { Take care of desk accessories }
            if GetNextEvent(EveryEvent, TheEvent) then { if there was an}
{                                                event... then }
                begin
                case TheEvent.What of { case out on the event type }
                    MouseDown: { we had a mouse-down event }
                        begin
                        MouseLoc := TheEvent.Where; { wheres the pesky mouse }
                        WindowLoc := FindWindow(MouseLoc, TheWindow); { find out}
{                where }
                        case WindowLoc of { now case on the location }
                            inMenuBar:
                                ProcessMenu(MenuSelect(MouseLoc)); { Handle}
{                  the selection }
                            Insyswindow:
                                SystemClick(TheEvent, TheWindow); {It was}
{                  in a desk acc }
                        end;
                    end;
                    KeyDown, AutoKey: { we had the user hit a key }
                        begin
                        TrickVar.i := TheEvent.Message; { fill the longWord }
                        CharCode := TrickVar.Chr0; { and pull off the low-byte }
                        if BitAnd(TheEvent.Modifiers, cmdKey) = cmdKey then { if}
{                   cmd down }
              { then go handle the menu }
                            ProcessMenu(MenuKey(CharCode));
                    end;
{ Modification PhC 11/02/98: case selector out of range }
                    otherwise
                        ;
                end; { of case event.what... }
            end;
        until (WindowLoc in Quoi); { end of repeat statement }
    end;

    procedure MiseaJourd (l: Integer);

    begin
        if EventAvail(Mdownmask, TheEvent) then
            Interruption;
        NumToString(l, Str2);
        SetDialogItemText(ItemHandle4, Str2);
    end;

    procedure MiseaJourg (l: Integer);

    begin
        if EventAvail(Mdownmask, TheEvent) then
            Interruption;
        NumToString(l, Str2);
        SetDialogItemText(ItemHandle3, Str2);
    end;

    procedure ShowFichier (var Fich: FileType;
                                    Index: Integer;
                                    DessinCourant: PicHandle;
                                    R: Rect;
                                    ThereWasAWindow: Boolean);

        var
            NbLignes, AncienMenuItem, LignesParEcran, PtrLignesSup, PtrLignesInf, i: Integer;
            RectUp, RectDown, ScrollRegion, ShowRect: Rect;
            Fini: Boolean;
            Espace: LongInt;
            OldPort: GrafPtr;
            Showwnd: Dialogptr;
            WindowPtr2: WindowPtr;
            Upd: RgnHandle;
            AncienMenu: Handle;
            NouveauMenu: MenuHandle;
            Space: PtrType;

        procedure ScrollInit (var Fich: FileType);

            var
                i, j, k: Integer;
                Car: Char;

            procedure InitScroll;

            begin
                SetCursor(ClockCursor^^);
                AncienMenuItem := MenuItem;
                AncienMenu := GetMenuBar;
                ClearMenuBar;
                InsertMenu(GetMenu(AppleID), 0);
                MenuFile := GetMenu(FileMenuID);
                InsertMenu(MenuFile, 0);
                InsertMenu(GetMenu(EditID), 0);
                InsertMenu(GetMenu(MenuID), 0);
                InsertMenu(GetMenu(MenuPr), 0);
                DisableItem(MenuFile, 2);
                DrawMenubar;
{$ifc undefined THINK_PASCAL}
                ShowRect := qd.ScreenBits.Bounds;
{$elsec}
                ShowRect := ScreenBits.Bounds;
{$endc}
                Showwnd := NewWindow(nil, ShowRect, 'Triangle', True, 3, WindowPtr(-1), False, Ref);
                GetPort(OldPort);
                SetPort(Showwnd);
                TextFont(4); { 4 = monaco }
                SetfScaleDisable(True);
                Upd := NewRgn;
                Upd^^.RgnSize := 10;
                SetRect(Upd^^.RgnbBox, 0, 0, 0, 0);
                SetRect(RectDown, 0, ShowRect.Bottom - 20, ShowRect.Right, ShowRect.Bottom - 10);
                SetRect(ScrollRegion, 0, MenuHeight, ShowRect.Right, ShowRect.Bottom);
                LignesParEcran := (RectDown.Bottom - MenuHeight) div 15 - 1;
                RectUp := RectDown;
                RectUp.Top := RectDown.Top - (LignesParEcran) * 15;
                RectUp.Bottom := RectDown.Bottom - (LignesParEcran) * 15;
            end;

        begin
            InitScroll;
            ResetFile(Fich);
            NbLignes := 0;
            Espace := 0;
            if not (EndOfFile(Fich)) then
                repeat
                    Str1 := ReadString(Fich, False);
                    ScrollRect(ScrollRegion, 0, -15, Upd);
{ Mod. 06/03/1998 PhC Cette ligne efface ce qu'on vient d'écrire! }
{ Je la mets donc entre commentaires }
{EraseRect(RectDown);}
                    MoveTo(RectDown.Left, RectDown.Bottom);
                    NbLignes := NbLignes + 1;
                    DrawString(Str1);
                until EndOfFile(Fich);
            ResetFile(Fich);
            Space.PtrGen := Memoire(0, NbLignes, 1, 1, LongBytes, True);
            with AdVec(Space.PtrGen, 0).PtrLong^ do
                Long := 0;
            for i := 1 to NbLignes do begin
                Str1 := ReadString(Fich, True);
                with AdVec(Space.PtrGen, i).PtrLong^ do
                    FileErr := GetfPos(Fich.FileNumber, Long);
            end;
            InitCursor;
            PtrLignesSup := NbLignes;
            PtrLignesInf := PtrLignesSup - LignesParEcran;
        end;

        procedure ScrollUpDown;

            var
                OuEstLaSouris: Point;
                Sens: Integer;

        begin
            while not (GetNextEvent(mUpMask, TheEvent)) do begin
                GetMouse(OuEstLaSouris);
                GlobalToLocal(OuEstLaSouris);
                with OuEstLaSouris do
                    if (v - ScrollRegion.Top < ScrollRegion.Bottom - v) then
                        Sens := -1
                    else
                        Sens := 1;
                if ((Sens = 1) and (PtrLignesSup < NbLignes)) or ((Sens = -1) and (PtrLignesInf > 0)) then begin
                    PtrLignesSup := PtrLignesSup + Sens;
                    PtrLignesInf := PtrLignesInf + Sens;
                    ScrollRect(ScrollRegion, 0, -15 * Sens, Upd);
                    if Sens = 1 then begin
                        MoveTo(RectDown.Left, RectDown.Bottom);
                        EraseRect(RectDown);
                        with AdVec(Space.PtrGen, PtrLignesSup - 1).PtrLong^ do
                            FileErr := SetfPos(Fich.FileNumber, fsFromStart, Long);
                    end
                    else begin
                        MoveTo(RectUp.Left, RectUp.Bottom);
                        EraseRect(RectUp);
                        with AdVec(Space.PtrGen, PtrLignesInf - 1).PtrLong^ do
                            FileErr := SetfPos(Fich.FileNumber, fsFromStart, Long);
                    end;
                    DrawString(ReadString(Fich, False));
                end;
            end;
        end;

    begin
        ScrollInit(Fich);
        repeat
            Fini := False;
            NextEvent([inMenuBar, InContent]);
            if FindWindow(TheEvent.Where, WindowPtr2) = InContent then
                ScrollUpDown
            else if MenuNum = MenuPr then begin
                Fini := True;
                if MenuItem = 1 then begin
                    if not (Sortie.vName) then
                        CreeSortie(Sortie, 2, 3);
                    ResetFile(Fich);
                    if not (EndOfFile(Fich)) then
                        repeat
                            Str1 := ReadString(Fich, False);
                            WriteString(Sortie, Str1);
                            WriteLnF(Sortie);
                        until EndOfFile(Fich);
                end
                else if MenuItem = 2 then
                    PrIntFichier(Fich);
                HiliteMenu(0);
            end;
        until (Fini) and (MenuItem = 3);
{ Mod. 06/03/1998 PhC Ce code cause une erreur -113 Zone Check }
{ Je préfère laisser une petite fuite de mémoire qu'un bug qui plante }
{    for i := 1 to NbLignes do}
{    Dispose(AdVec(Space.PtrGen, i).PtrStr);}
        DisposeMemoire(Space.PtrGen);
        DisposeWindow(Showwnd);
        SetPort(OldPort);
        if ThereWasAWindow then
            SelectWindow(OldPort); {!!! Modification 12}
{                                                  juin 1991}
        MenuItem := AncienMenuItem;
        ClearMenuBar;
        SetMenuBar(AncienMenu);
        DrawMenubar;
        DrawPicture(DessinCourant, R);
        EnableItem(MenuFile, 2);
    end; { ShowFichier }

    function LisReelorInt (var t: FileType;
                                    Abort: Boolean): DecStr;

        var
            Fait: Boolean;
            s: DecStr;
            i, CarInt: Integer;
            Car: Char;
            DebutPos, FinPos: LongInt;

    begin
        Fait := False;
        s := '';
        i := 0;
        CountByte := 1;
        if EndOfFile(t) then
            if Abort then
                ErrFile(1, t);
        while NextCar(t, False) in [Chr(9), Chr(13), ' '] do
            FileErr := fsRead(t.FileNumber, CountByte, @CarInt);
        if EndOfFile(t) then
            if Abort then
                ErrFile(1, t);
        FileErr := GetfPos(t.FileNumber, DebutPos);
        repeat
            FileErr := fsRead(t.FileNumber, CountByte, @CarInt);
        until (NextCar(t, False) in [' ', Chr(9), Chr(13)]) or (EndOfFile(t));
        FileErr := GetfPos(t.FileNumber, FinPos);
        FileErr := SetfPos(t.FileNumber, 1, DebutPos);
        FinPos := FinPos - DebutPos;
        i := FinPos;
        FileErr := fsRead(t.FileNumber, FinPos, @s[1]);
        FileErrHandler(t);
        s[0] := Chr(i);
        LisReelorInt := s;
    end;

    procedure Erreur2 (var t: FileType);

        var
            i, Position, LastCR: LongInt;
            CarInt, Ligne, Item: Integer;

    begin
        Ligne := 1;
        FileErr := GetfPos(t.FileNumber, Position);
        ResetFile(t);
        for i := 1 to Position do begin
            FileErr := fsRead(t.FileNumber, CountByte, @CarInt);
            if CarInt div 256 = 13 then begin
                Ligne := Ligne + 1;
                LastCR := i;
            end;
        end;
        Position := Position - LastCR - 1;
        FileErr := SetfPos(t.FileNumber, 1, LastCR);
        Str2 := ReadString(t, False);
        GetIndString(Str3, ErrFileID, 29);
        NumToString(Ligne, Str4);
        GetIndString(Str5, ErrFileID, 30);
        Str3 := Concat(Str3, Str4, Str5);
        NumToString(Position, Str4);
        Str3 := Concat(Str3, Str4);
        GetIndString(Str4, ErrFileID, 2);
        ParamText(Str2, Str3, Concat(Str4, t.Name), '');
        i := StopAlert(ErrFileID, nil);
        CloseThings;
    end;

    function LisReel (var t: FileType;
                                    Abort: Boolean): Extended;

        var
{$ifc undefined THINK_PASCAL}
            ValidPrefix: Integer;
{$elsec}
            ValidPrefix: Boolean;
{$endc}
            s: DecStr;
            Index: Integer;
            d: Decimal;
            Ff: record
                    case Boolean of
                        True: (
                                f: Extended
                        );
                        False: (
                                R: Extended
                        );
                end;

    begin
        Index := 1;
        s := LisReelorInt(t, Abort);
{$ifc undefined THINK_PASCAL}
        Str2Dec(@s, Index, d, ValidPrefix);
{$elsec}
        Str2Dec(s, Index, d, ValidPrefix);
{$endc}
        if not Boolean(ValidPrefix) then
            Erreur2(t);
        Ff.f := Str2Num(s);
        LisReel := Ff.R;
    end;

    function LisEntier (var t: FileType;
                                    Abort: Boolean): LongInt;

        var
            i, Debut: Integer;
            l: LongInt;
            s: DecStr;

    begin
        s := LisReelorInt(t, Abort);
        Debut := 1;
        if s[1] in ['-', '+'] then
            Debut := 2;
        for i := Debut to Length(s) do
            if not (s[i] in ['0'..'9']) then
                Erreur2(t);
        StringToNum(s, l);
        LisEntier := l;
    end;

    function LisID (var t: FileType;
                                    Abort: Boolean): Alpha;

        var
            i: Integer;
            Beta: Alpha;

    begin
        if EndOfFile(t) then
            if Abort then
                ErrFile(1, t);
        for i := 1 to 10 do begin
            if EndOfFile(t) then
                if Abort then
                    ErrFile(1, t);
            FileErr := fsRead(t.FileNumber, CountByte, @Beta[i]);
        end;
        LisID := Beta;
    end;

    function Memoire (Min1, Max1, Min2, Max2, lgBytes: LongInt;
                                    Piege: Boolean): Ptr;

        var
            Space: Size;
            ThePtr: PtrType;

    begin
        with ThePtr do begin
            NumToString(lgBytes, Str1);
            NumToString(Max1, Str3);
            Space := Max1 - Min1 + 1;
            Space := Space * (Max2 - Min2 + 1);
            Space := Space * lgBytes + 8;
            NumToString(Space, Str2);
            PtrGen := NewPtr(Space);
            with PtrInfo^ do begin
                OffSet1 := Min1;
                OffSet2 := Min2;
                Rang := Max2 - Min2 + 1;
                NbBytes := lgBytes;
            end;
            PtrEnt := PtrEnt + 8;
        end;
        if (MemError <> 0) and (Piege) then
            Erreurs(1, 0, 0, True)
        else
            Memoire := ThePtr.PtrGen;
    end;

    procedure DisposeMemoire (var ThePtr: Ptr);

        var
            a: PtrType;

    begin
        a.PtrGen := ThePtr;
        with a do begin
            PtrEnt := PtrEnt - 8;
            DisposePtr(PtrGen);
        end;
        ThePtr := nil;
    end;

    function AdMat (p: Ptr;
                                    v1, v2: LongInt): PtrType;

        var
            a, b: PtrType;

    begin
        a.PtrGen := p;
        b.PtrEnt := a.PtrEnt - 8;
        with b.PtrInfo^ do
            a.PtrEnt := a.PtrEnt + ((v1 - OffSet1) * Rang + (v2 - OffSet2)) * NbBytes;
        AdMat := a;
    end;

    {Function AdVec(P:Ptr;V:LongInt):PtrType;}
{    var a,b:PtrType;}
{        Mn,Mx:LongInt;}
{        By:Byte;}
{    begin}
{    a.PtrGen:=P;}
{    b.PtrEnt:=a.PtrEnt-14;}
{    By:=b.PtrInt^.Int;}
{    Mx:=By+a.PtrEnt;}
{    Mn:=a.PtrEnt;}
{    b.PtrEnt:=a.PtrEnt-8;}
{    with b.PtrInfo^ do}
{      a.PtrEnt:=a.PtrEnt+(V-Offset1)*NbBytes;}
{    if  (Numeros)then}
{      if (a.PtrEnt > Mx)Or(a.PtrEnt < Mn) then}
{        begin}
{        NumToString(Mn,Str1);}
{        NumToString(a.PtrEnt,Str2);}
{        NumToString(Mx,Str3);}
{        NumToString(v,Str4);}
{        DebugStr(Concat('AdVec ',Str4,' ',Str1,' ',Str2,' ',Str3));}
{        end;}
{    AdVec:=A;}
{    end;}

    function AdVec (p: Ptr;
                                    v: LongInt): PtrType;

        var
            a, b: PtrType;

    begin
        a.PtrGen := p;
        b.PtrEnt := a.PtrEnt - 8;
        with b.PtrInfo^ do
            a.PtrEnt := a.PtrEnt + (v - OffSet1) * NbBytes;
        AdVec := a;
    end;

    function AdLin (p: Ptr;
                                    v1, v2: Integer): PtrType;

        var
            a, b: PtrType;
            Ad: LongInt;

    begin
        Ad := v1;
        Ad := Ad * (Ad - 1) div 2 + v2 - 1;
        a.PtrGen := p;
        b.PtrEnt := a.PtrEnt - 8;
        with b.PtrInfo^ do
            a.PtrEnt := a.PtrEnt + Ad * NbBytes;
        AdLin := a;
    end;

    function AdBits (mm: Ptr;
                                    i: Integer): PtrType;

    begin
        AdBits.PtrEnt := Ord(mm) + i * BitsBytes;
    end;

    function Membre (Ind: Integer;
                                    mm: Ptr): Boolean;

        var
            i, j: Integer;

    begin
        i := Ind div NbBits;
        j := Ind mod NbBits;
        with AdBits(mm, i).PtrBits^ do
            Membre := j in Bits;
    end;

    procedure Ajoute (Ind: Integer;
                                    mm: Ptr);

        var
            i: Integer;

    begin
        i := Ind div NbBits;
        with AdBits(mm, i).PtrBits^ do
            Bits := Bits + [Ind mod NbBits];
    end;

    procedure Enleve (Ind: Integer;
                                    mm: Ptr);

        var
            i: Integer;

    begin
        i := Ind div NbBits;
        with AdBits(mm, i).PtrBits^ do
            Bits := Bits - [Ind mod NbBits];
    end;

    function Card (x: Ens): Integer;

        var
            c, i: Integer;

    begin
        c := 0;
        if x <> [] then
            for i := 0 to NbBitsl1 do
                if i in x then
                    c := c + 1;
        Card := c;
    end; { card }

    procedure Copy (m1, m2: Ptr);

        var
            i: Integer;

    begin
        for i := 0 to NbMots do begin
            with AdBits(m1, i).PtrBits^ do
                Bits := AdBits(m2, i).PtrBits^.Bits;
        end;
    end;

    function Vide (m: Ptr): Boolean;

        var
            i: Integer;
            b: Boolean;

    begin
        b := True;
        for i := 0 to NbMots do begin
            with AdBits(m, i).PtrBits^ do
                if Bits <> [] then
                    b := False;
        end;
        Vide := b;
    end;

    procedure NullVec (m: Ptr);

        var
            i: Integer;

    begin
        for i := 0 to NbMots do begin
            with AdBits(m, i).PtrBits^ do
                Bits := [];
        end;
    end;

    procedure Union (m1, m2: Ptr);

        var
            i: Integer;

    begin
        for i := 0 to NbMots do begin
            with AdBits(m1, i).PtrBits^ do
                Bits := Bits + AdBits(m2, i).PtrBits^.Bits;
        end;
    end;

    procedure Intersection (m0, m1, m2: Ptr);

        var
            i: Integer;

    begin
        for i := 0 to NbMots do begin
            with AdBits(m0, i).PtrBits^ do
                Bits := AdBits(m1, i).PtrBits^.Bits * AdBits(m2, i).PtrBits^.Bits;
        end;
    end;

    function InclusEgal (m1, m2: Ptr): Boolean;

        var
            i: Integer;
            bb: Boolean;

    begin
        bb := True;
        for i := 0 to NbMots do begin
            with AdBits(m1, i).PtrBits^ do
                if not (Bits <= AdBits(m2, i).PtrBits^.Bits) then
                    bb := False;
        end;
        InclusEgal := bb;
    end;

    function Egal (m1, m2: Ptr): Boolean;

        var
            i: Integer;
            bb: Boolean;

    begin
        bb := True;
        for i := 0 to NbMots do begin
            with AdBits(m1, i).PtrBits^ do
                if Bits <> AdBits(m2, i).PtrBits^.Bits then
                    bb := False;
        end;
        Egal := bb;
    end;

    procedure Difference (m1, m2: Ptr);

        var
            i: Integer;

    begin
        for i := 0 to NbMots do begin
            with AdBits(m1, i).PtrBits^ do
                Bits := Bits - AdBits(m2, i).PtrBits^.Bits;
        end;
    end;

    function CardVect (m: Ptr): Integer;

        var
            i, Compte: Integer;

    begin
        Compte := 0;
        for i := 0 to NbMots do begin
            with AdBits(m, i).PtrBits^ do
                Compte := Compte + Card(Bits);
        end;
        CardVect := Compte;
    end;

    procedure Premier (var i: Integer;
                                    t: Ptr);

    begin
        i := 0;
        repeat
            i := i + 1;
        until Membre(i, t);
    end;
end.